home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / turbovis / oodb.zip / DBDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1992-04-29  |  18KB  |  597 lines
  1. uses Objects, Drivers, Views, Menus, Dialogs, App, Layout, OODB;
  2.  
  3. const
  4.  
  5.    DBFileName = 'dbdemo.dat';
  6.  
  7.    MaxLen = 25;
  8.    CollLimit = $7F; CollDelta = 4;
  9.    InvPID = 1;
  10.  
  11.    cmInfo     = 100;
  12.  
  13.    cmOpen     = 101;
  14.    cmShut     = 102;
  15.    cmStat     = 103;
  16.  
  17.    cmCreate   = 105;
  18.    cmGet      = 106;
  19.    cmDelete   = 107;
  20.  
  21.    cmCommit   = 108;
  22.    cmAbort    = 109;
  23.  
  24. type
  25.  
  26.    NameString = String [MaxLen];
  27.  
  28.    ModDialData =
  29.       record
  30.          NameData : NameString
  31.       end;
  32.  
  33.    TInvCard =
  34.       record
  35.          Name : NameString;
  36.          ID   : Word
  37.       end;
  38.    PInvCard = ^TInvCard;
  39.  
  40. { ----- TCatCollection ----- }
  41.  
  42.       TCatCollection =
  43.          object (TSortedCollection)
  44.             procedure FreeItem (Item: Pointer);                  virtual;
  45.             function  GetItem  (var S: TStream): Pointer;        virtual;
  46.             procedure PutItem  (var S: TStream; Item: Pointer);  virtual;
  47.             function  Compare  (Key1, Key2 : Pointer): Integer;  virtual;
  48.          end;
  49.       PCatCollection = ^TCatCollection;
  50.  
  51. { ----- TDemoApplication class ----- }
  52.  
  53.    TDemoApplication =
  54.       object (TApplication)
  55.  
  56.          DB        : PBase;
  57.          DBFile    : PDosStream;
  58.  
  59.          constructor Init;
  60.          destructor  Done;                             virtual;
  61.          procedure   InitMenuBar;                      virtual;
  62.          procedure   InitStatusLine;                   virtual;
  63.          procedure   HandleEvent (var Event: TEvent);  virtual;
  64.          procedure   Idle;                             virtual;
  65.  
  66.          function    NameDialog (Title: TTitleStr):
  67.                                 PDialog;               virtual;
  68.  
  69.          procedure   About;                            virtual;
  70.  
  71.          procedure   OpenDB;                           virtual;
  72.          procedure   ShutDB;                           virtual;
  73.          procedure   StatInfo;                         virtual;
  74.  
  75.          procedure   CreateMod;                        virtual;
  76.          procedure   GetMod;                           virtual;
  77.          procedure   DeleteMod;                        virtual;
  78.  
  79.          procedure   Commit;                           virtual;
  80.          procedure   Rollback;                         virtual;
  81.  
  82.       end;
  83.    PDemoApplication = ^TDemoApplication;
  84.  
  85. { -- Implementation of TCatCollection -- }
  86.  
  87.    procedure TCatCollection.FreeItem (Item: Pointer);
  88.  
  89.       begin
  90.          Dispose (Item)
  91.       end;  { FreeItem }
  92.  
  93.    function TCatCollection.GetItem (var S: TStream): Pointer;
  94.  
  95.       var Item : PInvCard;
  96.  
  97.       begin
  98.          New (Item);
  99.          with S do
  100.               with Item^ do
  101.                    begin
  102.                       Read (Name, SizeOf(Name));
  103.                       Read (ID,   SizeOf(ID))
  104.                    end;
  105.          GetItem := Item
  106.       end;  { GetItem }
  107.  
  108.    procedure TCatCollection.PutItem (var S: TStream; Item: Pointer);
  109.  
  110.       begin
  111.          with S do
  112.               with TInvCard(Item^) do
  113.                    begin
  114.                       Write (Name, SizeOf(Name));
  115.                       Write (ID,   SizeOf(ID))
  116.                    end
  117.       end;  { PutItem }
  118.  
  119.    function TCatCollection.Compare (Key1, Key2 : Pointer): Integer;
  120.  
  121.       var
  122.          N1, N2 : NameString;
  123.       begin
  124.          N1 := TInvCard(Key1^).Name; N2 := TInvCard(Key2^).Name;
  125.          if N1 > N2
  126.             then Compare := 1
  127.             else if N1 < N2
  128.                     then Compare := -1
  129.                     else Compare := 0
  130.       end;  { Compare }
  131.  
  132. { -- End of TCatCollection implementation -- }
  133.  
  134. { ----- TDemoApplication implementation ----- }
  135.  
  136. { ----- Init ----- }
  137.  
  138.    constructor TDemoApplication.Init;
  139.  
  140.       begin
  141.          TApplication.Init;
  142.          DB := nil
  143.       end;
  144.  
  145. { ----- Done ----- }
  146.  
  147.    destructor TDemoApplication.Done;
  148.  
  149.       begin
  150.          if DB <> nil
  151.             then begin
  152.                     Dispose (DB, Done);
  153.                     Dispose (DBFile, Done)
  154.                  end;
  155.          TApplication.Done
  156.       end;
  157.  
  158. { ----- InitMenuBar ----- }
  159.  
  160.    procedure TDemoApplication.InitMenuBar;
  161.  
  162.       var
  163.          MenuRect: TRect;
  164.  
  165.       begin
  166.          GetExtent (MenuRect);
  167.          MenuRect.B.Y := MenuRect.A.Y + 1;
  168.          MenuBar := New (PMenuBar, Init (MenuRect, NewMenu (
  169.              NewItem ( '~I~nfo', '', kbNoKey, cmInfo, hcNoContext,
  170.              NewSubMenu ( '~D~atabase', hcNoContext, NewMenu (
  171.                 NewItem ( '~O~pen', 'F3', kbF3, cmOpen, hcNoContext,
  172.                 NewItem ( '~S~hut', 'F4', kbF4, cmShut, hcNoContext,
  173.                 NewItem ( 'S~t~atistics', '', kbNoKey, cmStat, hcNoContext,
  174.                 NewLine (
  175.                 NewItem ( '~E~xit', 'Alt-X', kbAltX, cmQuit, hcNoContext,
  176.                    nil )))))),
  177.              NewSubMenu ( '~M~odules', hcNoContext, NewMenu (
  178.                 NewItem ( '~C~reate', 'F5', kbF5, cmCreate, hcNoContext,
  179.                 NewItem ( '~G~et', 'F6', kbF6, cmGet, hcNoContext,
  180.                 NewItem ( '~D~elete', '', kbNoKey, cmDelete, hcNoContext,
  181.                    nil )))),
  182.              NewSubMenu ( '~T~ransaction', hcNoContext, NewMenu (
  183.                 NewItem ( '~C~ommit', '', kbNoKey, cmCommit, hcNoContext,
  184.                 NewItem ( '~R~ollback', '', kbNoKey, cmAbort, hcNoContext,
  185.                    nil ))),
  186.                   nil )))))))
  187.       end;
  188.  
  189. { ----- InitStatusLine ----- }
  190.  
  191.    procedure TDemoApplication.InitStatusLine;
  192.  
  193.       var
  194.          StatusRect: TRect;
  195.  
  196.       begin
  197.          GetExtent (StatusRect);
  198.          StatusRect.A.Y := StatusRect.B.Y - 1;
  199.          StatusLine := New (PStatusLine, Init (StatusRect,
  200.             NewStatusDef (0, $FFFF,
  201.                NewStatusKey ('~Alt-X~ - Exit', kbAltX, cmQuit,
  202.                NewStatusKey ('~F3~ - Open database', kbF3, cmOpen,
  203.                NewStatusKey ('~F10~ - Menu', kbF10, cmMenu,
  204.                   nil ))),
  205.                  nil )))
  206.       end;
  207.  
  208. { ----- HandleEvent ----- }
  209.  
  210.    procedure TDemoApplication.HandleEvent (var Event: TEvent);
  211.  
  212.       begin
  213.          TApplication.HandleEvent (Event);
  214.          with Event do
  215.               if What = evCommand
  216.                  then begin
  217.                          case Command of
  218.  
  219.                               cmInfo   : About;
  220.  
  221.                               cmOpen   : OpenDB;
  222.                               cmShut   : ShutDB;
  223.                               cmStat   : StatInfo;
  224.  
  225.                               cmCreate : CreateMod;
  226.                               cmGet    : GetMod;
  227.                               cmDelete : DeleteMod;
  228.  
  229.                               cmCommit : Commit;
  230.                               cmAbort  : Rollback;
  231.  
  232.                               else
  233.                                          Exit
  234.                           end;
  235.                           ClearEvent (Event)
  236.                       end
  237.       end;
  238.  
  239. { ----- Idle ----- }
  240.  
  241.    procedure TDemoApplication.Idle;
  242.  
  243.       begin
  244.          TApplication.Idle;
  245.          if DB <> nil
  246.             then DB^.IdlePack
  247.       end;
  248.  
  249. { ----- NameDialog ----- }
  250.  
  251.    function TDemoApplication.NameDialog (Title: TTitleStr): PDialog;
  252.  
  253.       var
  254.          X, Y     : Word;
  255.          R        : TRect;
  256.          Dial     : PDialog;
  257.          Bruce    : PView;
  258.  
  259.       begin
  260.          if DB = nil
  261.             then begin
  262.                     HandleError ( ^C'Open database at first !' );
  263.                     NameDialog := nil;
  264.                     Exit
  265.                  end;
  266.          Randomize;
  267.          X := 2 + Random (50); Y := 2 + Random (12);
  268.          R.Assign (X,Y,X+28,Y+9);
  269.          New (Dial, Init (R, Title));
  270.          with Dial^ do
  271.               begin
  272.                  R.Assign (2,6,12,8);
  273.                  Insert (New (PButton, Init (R, '~O~k', cmOK, bfDefault)));
  274.                  R.Assign (14,6,24,8);
  275.                  Insert (New (PButton,
  276.                               Init (R, '~C~ancel', cmCancel, bfNormal)));
  277.                  R.Assign (3,3,25,4);
  278.                  Bruce := New (PInputLine, Init (R, Max